home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / seqlib.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  25KB  |  697 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;   seqlib.lsp
  6. ;;;;
  7. ;;;;                           sequence routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12.  
  13. (export '(reduce fill replace
  14.           remove remove-if remove-if-not
  15.           delete delete-if delete-if-not
  16.           count count-if count-if-not
  17.           substitute substitute-if substitute-if-not
  18.           nsubstitute nsubstitute-if nsubstitute-if-not
  19.           find find-if find-if-not
  20.           position position-if position-if-not
  21.           remove-duplicates delete-duplicates
  22.           mismatch search
  23.           sort stable-sort merge))
  24.  
  25.  
  26. (in-package 'system)
  27.  
  28.  
  29. (proclaim '(optimize (safety 2) (space 3)))
  30.  
  31.  
  32. (proclaim '(function seqtype (t) t))
  33. (defun seqtype (sequence)
  34.   (cond ((listp sequence) 'list)
  35.         ((stringp sequence) 'string)
  36.         ((bit-vector-p sequence) 'bit-vector)
  37.         ((vectorp sequence) (list 'array (array-element-type sequence)))
  38.         (t (error "~S is not a sequence." sequence))))
  39.  
  40. (proclaim '(function call-test (t t t t) t))
  41. (defun call-test (test test-not item keyx)
  42.   (cond (test (funcall test item keyx))
  43.         (test-not (not (funcall test-not item keyx)))
  44.         (t (eql item keyx))))
  45.  
  46. (proclaim '(function check-seq-test (t t) t))
  47. (defun check-seq-test (test test-not)
  48.   (when (and test test-not)
  49.         (error "Both :TEST and :TEST-NOT were specified.")))
  50.  
  51. (proclaim '(function check-seq-start-end (t t) t))
  52. (defun check-seq-start-end (start end)
  53.   (unless (and (si:fixnump start) (si:fixnump end))
  54.           (error "Fixnum expected."))
  55.   (when (> (the fixnum start) (the fixnum end))
  56.         (error "START is greater than END.")))
  57.  
  58. (proclaim '(function check-seq-args (t t t t) t))
  59. (defun check-seq-args (test test-not start end)
  60.   (when (and test test-not)
  61.         (error "Both :TEST and :TEST-NOT were specified."))
  62.   (unless (and (si:fixnump start) (si:fixnump end))
  63.           (error "Fixnum expected."))
  64.   (when (> (the fixnum start) (the fixnum end))
  65.         (error "START is greater than END.")))
  66.  
  67.  
  68. (defun reduce (function sequence
  69.                &key from-end
  70.                     (start 0)
  71.                     (end (length sequence))
  72.                     (initial-value nil ivsp))
  73.   (check-seq-start-end start end)
  74.   (let ((start start) (end end))
  75.     (declare (fixnum start end))
  76.     (cond ((not from-end)
  77.            (when (null ivsp)
  78.                  (when (>= start end)
  79.                        (return-from reduce (funcall function)))
  80.                  (setq initial-value (elt sequence start))
  81.                  (incf start))
  82.            (do ((x initial-value
  83.                    (funcall function x (prog1 (elt sequence start)
  84.                                               (incf start)))))
  85.                ((>= start end) x)))
  86.           (t
  87.            (when (null ivsp)
  88.                  (when (>= start end)
  89.                        (return-from reduce (funcall function)))
  90.                  (decf end)
  91.                  (setq initial-value (elt sequence end)))
  92.            (do ((x initial-value (funcall function (elt sequence end) x)))
  93.                ((>= start end) x)
  94.              (decf end))))))
  95.  
  96.  
  97. (defun fill (sequence item
  98.          &key (start 0) (end (length sequence)))
  99.   (check-seq-start-end start end)
  100.   (let ((start start) (end end))
  101.     (declare (fixnum start end))
  102.     (do ((i start (1+ i)))
  103.         ((>= i end) sequence)
  104.       (declare (fixnum i))
  105.       (setf (elt sequence i) item))))
  106.  
  107.  
  108. (defun replace (sequence1 sequence2
  109.             &key (start1 0) (end1 (length sequence1))
  110.              (start2 0) (end2 (length sequence2)))
  111.   (check-seq-start-end start1 end1)
  112.   (check-seq-start-end start2 end2)
  113.   (let ((start1 start1) (end1 end1) (start2 start2) (end2 end2))
  114.     (declare (fixnum start1 end1 start2 end2))
  115.     (if (and (eq sequence1 sequence2)
  116.              (> start1 start2))
  117.         (do* ((i 0 (1+ i))
  118.               (l (if (< (the fixnum (- end1 start1))
  119.                         (the fixnum (- end2 start2)))
  120.                      (the fixnum (- end1 start1))
  121.                      (the fixnum (- end2 start2))))
  122.               (s1 (+ start1 (the fixnum (1- l))) (1- s1))
  123.               (s2 (+ start2 (the fixnum (1- l))) (1- s2)))
  124.             ((>= i l) sequence1)
  125.           (declare (fixnum i l s1 s2))
  126.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  127.         (do ((i 0 (1+ i))
  128.              (l (if (< (the fixnum (- end1 start1))
  129.                        (the fixnum (- end2 start2)))
  130.                     (the fixnum (- end1 start1))
  131.                     (the fixnum (- end2 start2))))
  132.              (s1 start1 (1+ s1))
  133.              (s2 start2 (1+ s2)))
  134.             ((>= i l) sequence1)
  135.           (declare (fixnum i l s1 s2))
  136.           (setf (elt sequence1 s1) (elt sequence2 s2))))))
  137.  
  138.  
  139. ;;; DEFSEQ macro.
  140. ;;; Usage:
  141. ;;;
  142. ;;;    (DEFSEQ function-name argument-list countp everywherep body)
  143. ;;;
  144. ;;; The arguments ITEM and SEQUENCE (PREDICATE and SEQUENCE)
  145. ;;;  and the keyword arguments are automatically supplied.
  146. ;;; If the function has the :COUNT argument, set COUNTP T.
  147.  
  148. (eval-when (eval compile)
  149. (defmacro defseq
  150.           (f args countp everywherep body
  151.            &aux (*macroexpand-hook* 'funcall))
  152.   (setq *body* body)
  153.   (list 'progn
  154.         (let* ((from-end nil)
  155.                (iterate-i '(i start (1+ i)))
  156.                (iterate-i-from-end '(i (1- end) (1- i)))
  157.                (endp-i '(>= i end))
  158.                (endp-i-from-end '(< i start))
  159.                (iterate-i-everywhere '(i 0 (1+ i)))
  160.                (iterate-i-everywhere-from-end '(i (1- l) (1- i)))
  161.                (endp-i-everywhere '(>= i l))
  162.                (endp-i-everywhere-from-end '(< i 0))
  163.                (i-in-range '(and (<= start i) (< i end)))
  164.                (x '(elt sequence i))
  165.                (keyx `(funcall key ,x))
  166.                (satisfies-the-test `(call-test test test-not item ,keyx))
  167.                (number-satisfied
  168.                 `(n (internal-count item sequence
  169.                                     :from-end from-end
  170.                                     :test test :test-not test-not
  171.                                     :start start :end end
  172.                                     ,@(if countp '(:count count))
  173.                                     :key key)))
  174.                (within-count '(< k count))
  175.                (kount-0 '(k 0))
  176.                (kount-up '(setq k (1+ k))))
  177.            `(defun ,f (,@args item sequence
  178.                        &key from-end test test-not
  179.                             (start 0) (end (length sequence))
  180.                             ,@(if countp '((count (length sequence))))
  181.                             (key #'identity)
  182.                        ,@(if everywherep
  183.                              (list '&aux '(l (length sequence)))
  184.                              nil))
  185.               ,@(if countp '((declare (fixnum count))))
  186.               ,@(if everywherep '((declare (fixnum l))))
  187.               (check-seq-args test test-not start end)
  188.               (let ((start start) (end end))
  189.                 (declare (fixnum start end))
  190.                 (if (not from-end)
  191.                     ,(eval-body)
  192.                     ,(progn (setq from-end t
  193.                                   iterate-i iterate-i-from-end
  194.                                   endp-i endp-i-from-end
  195.                                   iterate-i-everywhere
  196.                                   iterate-i-everywhere-from-end
  197.                                   endp-i-everywhere
  198.                                   endp-i-everywhere-from-end)
  199.                             (eval-body))))))
  200.         `(defun ,(intern (si:string-concatenate (string f) "-IF")
  201.                          (symbol-package f))
  202.                 (,@args predicate sequence
  203.                  &key from-end
  204.                       (start 0) (end (length sequence))
  205.                       ,@(if countp '((count (length sequence))))
  206.                       (key #'identity))
  207.            (,f ,@args predicate sequence
  208.                :from-end from-end
  209.                :test #'funcall
  210.                :start start :end end
  211.                ,@(if countp '(:count count))
  212.                :key key))
  213.         `(defun ,(intern (si:string-concatenate (string f) "-IF-NOT")
  214.                          (symbol-package f))
  215.                 (,@args predicate sequence
  216.                  &key from-end
  217.                       (start 0) (end (length sequence))
  218.                       ,@(if countp '((count (length sequence))))
  219.                       (key #'identity))
  220.            (,f ,@args predicate sequence
  221.                :from-end from-end
  222.                :test-not #'funcall
  223.                :start start :end end
  224.                ,@(if countp '(:count count))
  225.                :key key))
  226.         (list 'quote f)))
  227.  
  228. (defmacro eval-body () *body*)
  229. )
  230.  
  231.  
  232. (defseq remove () t nil
  233.   (if (not from-end)
  234.       `(if (listp sequence)
  235.            (let ((l sequence) (l1 nil))
  236.              (do ((i 0 (1+ i)))
  237.                  ((>= i start))
  238.                (declare (fixnum i))
  239.                (push (car l) l1)
  240.                (pop l))
  241.              (do ((i start (1+ i)) (j 0))
  242.                  ((or (>= i end) (>= j count) (endp l))
  243.                   (nreconc l1 l))
  244.                (declare (fixnum i j))
  245.                (cond ((call-test test test-not item (funcall key (car l)))
  246.                       (incf j)
  247.                       (pop l))
  248.                      (t
  249.                       (push (car l) l1)
  250.                       (pop l)))))
  251.            (delete item sequence
  252.                    :from-end from-end
  253.                    :test test :test-not test-not
  254.                    :start start :end end
  255.                    :count count
  256.                    :key key))
  257.       `(delete item sequence
  258.                :from-end from-end
  259.                :test test :test-not test-not
  260.                :start start :end end
  261.                :count count
  262.                :key key)))
  263.  
  264.  
  265. (defseq delete () t t
  266.   (if (not from-end)
  267.       `(if (listp sequence)
  268.            (let* ((l0 (cons nil sequence)) (l l0))
  269.              (do ((i 0 (1+ i)))
  270.                  ((>= i start))
  271.                (declare (fixnum i))
  272.                (pop l))
  273.              (do ((i start (1+ i)) (j 0))
  274.                  ((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0))
  275.                (declare (fixnum i j))
  276.                (cond ((call-test test test-not item (funcall key (cadr l)))
  277.                       (incf j)
  278.                       (rplacd l (cddr l)))
  279.                      (t (setq l (cdr l))))))
  280.            (let (,number-satisfied)
  281.              (declare (fixnum n))
  282.              (when (< n count) (setq count n))
  283.              (do ((newseq
  284.                    (make-sequence (seqtype sequence)
  285.                                   (the fixnum (- l count))))
  286.                   ,iterate-i-everywhere
  287.                   (j start)
  288.                   ,kount-0)
  289.                  (,endp-i-everywhere newseq)
  290.                (declare (fixnum i j k))
  291.                (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  292.                       ,kount-up)
  293.                      (t (setf (elt newseq j) ,x)
  294.                         (incf j))))))
  295.       `(let (,number-satisfied)
  296.          (declare (fixnum n))
  297.          (when (< n count) (setq count n))
  298.          (do ((newseq
  299.                (make-sequence (seqtype sequence) (the fixnum (- l count))))
  300.               ,iterate-i-everywhere
  301.               (j (- (the fixnum (1- end)) n))
  302.               ,kount-0)
  303.              (,endp-i-everywhere newseq)
  304.            (declare (fixnum i j k))
  305.            (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  306.                   ,kount-up)
  307.                  (t (setf (elt newseq j) ,x)
  308.                     (decf j)))))))
  309.  
  310.  
  311. (defseq count () nil nil
  312.   `(do (,iterate-i ,kount-0)
  313.        (,endp-i k)
  314.      (declare (fixnum i k))
  315.      (when (and ,satisfies-the-test)
  316.            ,kount-up)))
  317.  
  318.  
  319. (defseq internal-count () t nil
  320.   `(do (,iterate-i ,kount-0)
  321.        (,endp-i k)
  322.      (declare (fixnum i k))
  323.      (when (and ,within-count ,satisfies-the-test)
  324.            ,kount-up)))
  325.  
  326.  
  327. (defseq substitute (newitem) t t
  328.   `(do ((newseq (make-sequence (seqtype sequence) l))
  329.         ,iterate-i-everywhere
  330.         ,kount-0)
  331.        (,endp-i-everywhere newseq)
  332.      (declare (fixnum i k))
  333.      (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  334.             (setf (elt newseq i) newitem)
  335.             ,kount-up)
  336.            (t (setf (elt newseq i) ,x))))))
  337.  
  338.  
  339. (defseq nsubstitute (newitem) t nil
  340.   `(do (,iterate-i ,kount-0)
  341.        (,endp-i sequence)
  342.      (declare (fixnum i k))
  343.      (when (and ,within-count ,satisfies-the-test)
  344.            (setf ,x newitem)
  345.            ,kount-up)))
  346.  
  347.  
  348. (defseq find () nil nil
  349.   `(do (,iterate-i)
  350.        (,endp-i nil)
  351.      (declare (fixnum i))
  352.      (when ,satisfies-the-test (return ,x))))
  353.  
  354.  
  355. (defseq position () nil nil
  356.   `(do (,iterate-i)
  357.        (,endp-i nil)
  358.      (declare (fixnum i))
  359.      (when ,satisfies-the-test (return i))))
  360.  
  361.  
  362. (defun remove-duplicates (sequence
  363.                           &key from-end
  364.                                test test-not
  365.                                (start 0 startsp)
  366.                                (end (length sequence) endsp)
  367.                                (key #'identity))
  368.   (check-seq-args test test-not start end)
  369.   (when (and (listp sequence) (not from-end) (not startsp) (not endsp))
  370.         (when (endp sequence) (return-from remove-duplicates nil))
  371.         (do ((l sequence (cdr l)) (l1 nil))
  372.             ((endp (cdr l))
  373.              (return-from remove-duplicates (nreconc l1 l)))
  374.           (unless (member1 (car l) (cdr l)
  375.                            :test test :test-not test-not
  376.                            :key key)
  377.                   (setq l1 (cons (car l) l1)))))
  378.   (delete-duplicates sequence
  379.                      :from-end from-end
  380.                      :test test :test-not test-not
  381.                      :start start :end end
  382.                      :key key))
  383.        
  384.  
  385. (defun delete-duplicates (sequence
  386.                           &key from-end
  387.                                test test-not
  388.                                (start 0 startsp)
  389.                                (end (length sequence) endsp)
  390.                                (key #'identity)
  391.                           &aux (l (length sequence)))
  392.   (declare (fixnum l))
  393.   (check-seq-args test test-not start end)
  394.   (when (and (listp sequence) (not from-end) (not startsp) (not endsp))
  395.         (when (endp sequence) (return-from delete-duplicates nil))
  396.         (do ((l sequence))
  397.             ((endp (cdr l))
  398.              (return-from delete-duplicates sequence))
  399.             (cond ((member1 (car l) (cdr l)
  400.                             :test test :test-not test-not
  401.                             :key key)
  402.                    (rplaca l (cadr l))
  403.                    (rplacd l (cddr l)))
  404.                   (t (setq l (cdr l))))))
  405.   (let ((start start) (end end))
  406.     (declare (fixnum start end))
  407.     (if (not from-end)
  408.         (do ((n 0)
  409.              (i start (1+ i)))
  410.             ((>= i end)
  411.              (do ((newseq (make-sequence (seqtype sequence)
  412.                                          (the fixnum (- l n))))
  413.                   (i 0 (1+ i))
  414.                   (j 0))
  415.                  ((>= i l) newseq)
  416.                (declare (fixnum i j))
  417.                (cond ((and (<= start i)
  418.                            (< i end)
  419.                            (position (funcall key (elt sequence i))
  420.                                      sequence
  421.                                      :test test
  422.                                      :test-not test-not
  423.                                      :start (the fixnum (1+ i))
  424.                                      :end end
  425.                                      :key key)))
  426.                      (t
  427.                       (setf (elt newseq j) (elt sequence i))
  428.                       (incf j)))))
  429.           (declare (fixnum n i))
  430.           (when (position (funcall key (elt sequence i))
  431.                           sequence
  432.                           :test test
  433.                           :test-not test-not
  434.                           :start (the fixnum (1+ i))
  435.                           :end end
  436.                           :key key)
  437.                 (incf n)))
  438.         (do ((n 0)
  439.              (i (1- end) (1- i)))
  440.             ((< i start)
  441.              (do ((newseq (make-sequence (seqtype sequence)
  442.                                          (the fixnum (- l n))))
  443.                   (i (1- l) (1- i))
  444.                   (j (- (the fixnum (1- l)) n)))
  445.                  ((< i 0) newseq)
  446.                (declare (fixnum i j))
  447.                (cond ((and (<= start i)
  448.                            (< i end)
  449.                            (position (funcall key (elt sequence i))
  450.                                      sequence
  451.                                      :from-end t
  452.                                      :test test
  453.                                      :test-not test-not
  454.                                      :start start
  455.                                      :end i
  456.                                      :key key)))
  457.                      (t
  458.                       (setf (elt newseq j) (elt sequence i))
  459.                       (decf j)))))
  460.           (declare (fixnum n i))
  461.           (when (position (funcall key (elt sequence i))
  462.                           sequence
  463.                           :from-end t
  464.                           :test test
  465.                           :test-not test-not
  466.                           :start start
  467.                           :end i
  468.                           :key key)
  469.                 (incf n))))))
  470.        
  471.  
  472. (defun mismatch (sequence1 sequence2
  473.          &key from-end test test-not
  474.               (key #'identity)
  475.               (start1 0)
  476.               (start2 0)
  477.               (end1 (length sequence1))
  478.               (end2 (length sequence2)))
  479.   (check-seq-test test test-not)
  480.   (check-seq-start-end start1 end1)
  481.   (check-seq-start-end start2 end2)
  482.   (let ((start1 start1) (end1 end1) (start2 start2) (end2 end2))
  483.     (declare (fixnum start1 end1 start2 end2))
  484.     (if (not from-end)
  485.         (do ((i1 start1 (1+ i1))
  486.              (i2 start2  (1+ i2)))
  487.             ((or (>= i1 end1) (>= i2 end2))
  488.              (if (and (>= i1 end1) (>= i2 end2)) nil i1))
  489.           (declare (fixnum i1 i2))
  490.           (unless (call-test test test-not
  491.                              (funcall key (elt sequence1 i1))
  492.                              (funcall key (elt sequence2 i2)))
  493.                   (return i1)))
  494.         (do ((i1 (1- end1) (1- i1))
  495.              (i2 (1- end2)  (1- i2)))
  496.             ((or (< i1 start1) (< i2 start2))
  497.              (if (and (< i1 start1) (< i2 start2)) nil i1))
  498.           (declare (fixnum i1 i2))
  499.           (unless (call-test test test-not
  500.                              (funcall key (elt sequence1 i1))
  501.                              (funcall key (elt sequence2 i2)))
  502.                   (return i1))))))
  503.  
  504.  
  505. (defun search (sequence1 sequence2
  506.                &key from-end test test-not 
  507.                     (key #'identity)
  508.                     (start1 0)
  509.                     (start2 0)
  510.                     (end1 (length sequence1))
  511.                     (end2 (length sequence2)))
  512.   (check-seq-test test test-not)
  513.   (check-seq-start-end start1 end1)
  514.   (check-seq-start-end start2 end2)
  515.   (let ((start1 start1) (end1 end1) (start2 start2) (end2 end2))
  516.     (declare (fixnum start1 end1 start2 end2))
  517.     (if (not from-end)
  518.         (loop
  519.          (do ((i1 start1 (1+ i1))
  520.               (i2 start2 (1+ i2)))
  521.              ((>= i1 end1) (return-from search start2))
  522.            (declare (fixnum i1 i2))
  523.            (when (>= i2 end2) (return-from search nil))
  524.            (unless (call-test test test-not
  525.                               (funcall key (elt sequence1 i1))
  526.                               (funcall key (elt sequence2 i2)))
  527.                    (return nil)))
  528.          (incf start2))
  529.         (loop
  530.          (do ((i1 (1- end1) (1- i1))
  531.               (i2 (1- end2) (1- i2)))
  532.              ((< i1 start1) (return-from search (the fixnum (1+ i2))))
  533.            (declare (fixnum i1 i2))
  534.            (when (< i2 start2) (return-from search nil))
  535.            (unless (call-test test test-not
  536.                               (funcall key (elt sequence1 i1))
  537.                               (funcall key (elt sequence2 i2)))
  538.                    (return nil)))
  539.          (decf end2)))))
  540.  
  541.  
  542. (defun sort (sequence predicate &key (key #'identity))
  543.   (if (listp sequence)
  544.       (list-merge-sort sequence predicate key)
  545.       (quick-sort sequence 0 (the fixnum (length sequence)) predicate key)))
  546.  
  547.  
  548. (defun list-merge-sort (l predicate key)
  549.   (labels
  550.    ((sort (l)
  551.       (prog ((i 0) left right l0 l1 key-left key-right)
  552.         (declare (fixnum i))
  553.         (setq i (length l))
  554.         (cond ((< i 2) (return l))
  555.               ((= i 2)
  556.                (setq key-left (funcall key (car l)))
  557.                (setq key-right (funcall key (cadr l)))
  558.                (cond ((funcall predicate key-left key-right) (return l))
  559.                      ((funcall predicate key-right key-left)
  560.                       (return (nreverse l)))
  561.                      (t (return l)))))
  562.         (setq i (floor i 2))
  563.         (do ((j 1 (1+ j)) (l1 l (cdr l1)))
  564.             ((>= j i)
  565.              (setq left l)
  566.              (setq right (cdr l1))
  567.              (rplacd l1 nil))
  568.           (declare (fixnum j)))
  569.         (setq left (sort left))
  570.         (setq right (sort right))
  571.         (cond ((endp left) (return right))
  572.               ((endp right) (return left)))
  573.         (setq l0 (cons nil nil))
  574.         (setq l1 l0)
  575.         (setq key-left (funcall key (car left)))
  576.         (setq key-right (funcall key (car right)))
  577.       loop
  578.         (cond ((funcall predicate key-left key-right) (go left))
  579.               ((funcall predicate key-right key-left) (go right))
  580.               (t (go left)))
  581.       left
  582.         (rplacd l1 left)
  583.         (setq l1 (cdr l1))
  584.         (setq left (cdr left))
  585.         (when (endp left)
  586.               (rplacd l1 right)
  587.               (return (cdr l0)))
  588.         (setq key-left (funcall key (car left)))
  589.         (go loop)
  590.       right
  591.         (rplacd l1 right)
  592.         (setq l1 (cdr l1))
  593.         (setq right (cdr right))
  594.         (when (endp right)
  595.               (rplacd l1 left)
  596.               (return (cdr l0)))
  597.         (setq key-right (funcall key (car right)))
  598.         (go loop))))
  599.    (sort l)))
  600.  
  601.  
  602. #|
  603. (defun list-quick-sort (l predicate key)
  604.   (if (or (endp l) (endp (cdr l)))
  605.       l
  606.       (multiple-value-bind (x y)
  607.           (list-quick-sort-partition (car l) (cdr l) predicate key)
  608.         (nconc (list-quick-sort x predicate key)
  609.                (list (car l))
  610.                (list-quick-sort y predicate key)))))
  611.  
  612. (defun list-quick-sort-partition (k l predicate key)
  613.   (do ((l l (cdr l)) (x nil) (y nil))
  614.       ((endp l) (values (nreverse x) (nreverse y)))
  615.     (if (funcall predicate (funcall key (car l)) (funcall key k))
  616.         (setq x (cons (car l) x))
  617.         (setq y (cons (car l) y)))))
  618. |#
  619.  
  620.  
  621. (proclaim '(function quick-sort (t fixnum fixnum t t)))
  622.  
  623. (defun quick-sort (sequence start end predicate key &aux (j 0) (k 0))
  624.   (declare (fixnum start end j k))
  625.   (when (<= end (the fixnum (1+ start)))
  626.         (return-from quick-sort sequence))
  627.   (setq j start)
  628.   (setq k (1- end))
  629.   (do ((d (elt sequence start)))
  630.       ((> j k))
  631.     (do ()
  632.     ((or (> j k)
  633.          (funcall predicate
  634.               (funcall key (elt sequence k))
  635.               (funcall key d))))
  636.       (decf k))
  637.     (when (< k start)
  638.       (quick-sort sequence (1+ start) end predicate key)
  639.       (return-from quick-sort sequence))
  640.     (do ()
  641.     ((or (> j k)
  642.          (not (funcall predicate
  643.                (funcall key (elt sequence j))
  644.                (funcall key d)))))
  645.       (incf j))
  646.     (when (> j k) (return))
  647.     (psetf (elt sequence j) (elt sequence k)
  648.            (elt sequence k) (elt sequence j))
  649.     (incf j)
  650.     (decf k))
  651.   (quick-sort sequence start j predicate key)
  652.   (quick-sort sequence j end predicate key)
  653.   sequence)
  654.  
  655.  
  656. (defun stable-sort (sequence predicate &key (key #'identity))
  657.   (if (listp sequence)
  658.       (list-merge-sort sequence predicate key)
  659.       (if (or (stringp sequence) (bit-vector-p sequence))
  660.           (sort sequence predicate :key key)
  661.           (coerce (list-merge-sort (coerce sequence 'list)
  662.                                    predicate
  663.                                    key)
  664.                   (seqtype sequence)))))
  665.  
  666.  
  667. (defun merge (result-type sequence1 sequence2 predicate
  668.           &key (key #'identity)
  669.           &aux (l1 (length sequence1)) (l2 (length sequence2)))
  670.   (declare (fixnum l1 l2))
  671.   (do ((newseq (make-sequence result-type (the fixnum (+ l1 l2))))
  672.        (j 0 (1+ j))
  673.        (i1 0)
  674.        (i2 0))
  675.       ((and (= i1 l1) (= i2 l2)) newseq)
  676.     (declare (fixnum j i1 i2))
  677.     (cond ((and (< i1 l1) (< i2 l2))
  678.        (cond ((funcall predicate
  679.                (funcall key (elt sequence1 i1))
  680.                (funcall key (elt sequence2 i2)))
  681.           (setf (elt newseq j) (elt sequence1 i1))
  682.           (incf i1))
  683.          ((funcall predicate
  684.                (funcall key (elt sequence2 i2))
  685.                (funcall key (elt sequence1 i1)))
  686.           (setf (elt newseq j) (elt sequence2 i2))
  687.           (incf i2))
  688.          (t
  689.           (setf (elt newseq j) (elt sequence1 i1))
  690.           (incf i1))))
  691.           ((< i1 l1)
  692.        (setf (elt newseq j) (elt sequence1 i1))
  693.        (incf i1))
  694.       (t
  695.        (setf (elt newseq j) (elt sequence2 i2))
  696.        (incf i2)))))
  697.